PC Professionell 2006 May/PCpro_2006_05.ISO/files/mobile/fma-2.0-stable-setup.exe/{app}/source/uOutlookSync.pas

Pascal/Delphi Source File | 2004-07-25 | 8.6 KB | 316 lines

unit uOutlookSync;

{
*******************************************************************************
* Descriptions: Outlook Contact Sync Unit
* $Source: /cvsroot/fma/fma/uOutlookSync.pas,v $
* $Locker:  $
*
* Todo:
*
* Change Log:
* $Log: uOutlookSync.pas,v $
* Revision 1.5  2004/07/25 13:30:37  lordlarry
* Added the ability to select the Outlook folder where all the New contacts end up.
*
* Revision 1.4  2004/06/25 18:27:09  lordlarry
* Added this changelog header
*
*
}

interface

uses
  uContactSync, Outlook8, Classes;

type
  TOutlookContact = class(TContact)
  private
    FOutlookContact: ContactItem;
  protected
    function Exists: Boolean; override;
  public
    property OutlookContact: ContactItem read FOutlookContact write FOutlookContact;
  end;

  TOutlookContactSource = class(TContactSource)
  private
    Outlook: OutlookApplication;
    NmSpace: NameSpace;
    FCategories: TStrings;
    FFolders: TStrings;
    FNewContactsFolder: String;
    FNewContactsFolderFolder: MAPIFolder;
    function InCategories(OutlookContact: ContactItem): Boolean;
    procedure SetCategories(const Value: TStrings);
    procedure SetFolders(const Value: TStrings);
    procedure SetNewContactsFolder(const Value: String);
  protected
    function GetName: String; override;
    function GetOutlookCategories: String;
    function ExtractQuotedStr(Str: String): String;
    procedure Read(Contact: TOutlookContact; OutlookContact: ContactItem);
  public
    constructor Create;
    destructor Destroy; override;

    function New: TContact; override;
    function Add(Value: TContact): TContact; override;
    procedure Update(Contact, Value: TContact); override;
    procedure Delete(Contact: TContact); override;

    procedure Load; override;

    property Categories: TStrings read FCategories write SetCategories;
    property Folders: TStrings read FFolders write SetFolders;
    property NewContactsFolder: String read FNewContactsFolder write SetNewContactsFolder;
  end;

implementation

uses
  SysUtils, Forms;

{ TOutlookContactSource }

function TOutlookContactSource.GetOutlookCategories: String;
var I: Integer;
begin
  Result := '';
  for I := 0 to Categories.Count - 1 do
    if Trim(Categories[I]) <> '' then begin
      if Result <> '' then Result := Result + '; ';
      Result := Result + Categories[I];
    end;
end;

function TOutlookContactSource.Add(Value: TContact): TContact;
var
  Contact: TOutlookContact;
begin
  Contact := New as TOutlookContact;
  Contact.Clone(Value);
  Contact.LinkedContact := Value;
  Value.LinkedContact := Contact;
  Contacts.Add(Contact);

  if Assigned(FNewContactsFolderFolder) then
    Contact.OutlookContact := FNewContactsFolderFolder.Items.Add(olContactItem) as ContactItem
  else
    Contact.OutlookContact := Outlook.CreateItem(olContactItem) as ContactItem;

  with Contact.OutlookContact do begin
    Title := Contact.Title;
    FirstName := Contact.Name;
    LastName := Contact.SurName;
    CompanyName := Contact.Organization;
    Email1Address := Contact.Email;
    HomeTelephoneNumber := Contact.HomePhone;
    BusinessTelephoneNumber := Contact.WorkPhone;
    MobileTelephoneNumber := Contact.CellPhone;
    HomeFaxNumber := Contact.FaxPhone;
    OtherTelephoneNumber := Contact.OtherPhone;

    Categories := GetOutlookCategories;

    Save;

    Contact.ID := EntryID;
  end;

  Result := Contact;
end;

constructor TOutlookContactSource.Create;
begin
  inherited;
  FCategories := TStringList.Create;
  FCategories.Delimiter := ';';
  FFolders := TStringList.Create;

  Outlook := CoOutlookApplication.Create;
  NmSpace := Outlook.GetNamespace('MAPI');
//  NmSpace.Logon('', '', False, False);
end;

procedure TOutlookContactSource.Delete(Contact: TContact);
begin
  with Contact as TOutlookContact do begin
    OutlookContact.Delete;

    OutlookContact := nil;
  end;
end;

destructor TOutlookContactSource.Destroy;
begin
  FCategories.Free;
  FFolders.Free;

  inherited;
end;

function TOutlookContactSource.ExtractQuotedStr(Str: String): String;
var P: PChar;
begin
  P := PChar(Str);
  Result := AnsiExtractQuotedStr(P, '"');
  if Result = '' then Result := Str;
end;

function TOutlookContactSource.GetName: String;
begin
  Result := 'Outlook';
end;

function TOutlookContactSource.InCategories(OutlookContact: ContactItem): Boolean;
var Cats, Cat: String;
    P: Integer;
begin
  if Categories.Count > 0 then begin
    Result := False;
    Cats := OutlookContact.Categories;
    while Cats <> '' do begin
      P := Pos(';', Cats);
      if P = 0 then  // A propper Outlook Version check would be better
        P := Pos(',', Cats);  // Outlook 2003 uses , instead of ;
      if P = 0 then
        P := Length(Cats) + 1;

      Cat := Trim(Copy(Cats, 1, P - 1));
      System.Delete(Cats, 1, P);

      Result := Categories.IndexOf(Cat) <> - 1;
      if Result then Break;
    end;
  end
  else
    Result := True;
end;

procedure TOutlookContactSource.Load;
  procedure LoadFolder(Folder: MAPIFolder);
  var I: Integer;
      OutlookContact: ContactItem;
      Contact: TOutlookContact;
      Count, CountNew, CountFiltered: Integer;
  begin
    Count := 0;
    CountNew := 0;
    CountFiltered := 0;

    for I := 1 to Folder.Items.Count do
      if Supports(Folder.Items.Item(I), ContactItem, OutlookContact) then begin
        if InCategories(OutlookContact) then begin
          Contact := Contacts.FindByID(OutlookContact.EntryID) as TOutlookContact;

          if Assigned(Contact) then begin
            Contact.OutlookContact := OutlookContact;
          end
          else begin
            Contact := New as TOutlookContact;
            Contact.ID := OutlookContact.EntryID;
            Contact.SyncHash := Contact.Hash;
            Contact.OutlookContact := OutlookContact;
            Contacts.Add(Contact);

            Inc(CountNew);
          end;

          Read(Contact, OutlookContact);

          Inc(Count);
        end
        else
          Inc(CountFiltered);

        Application.ProcessMessages;
      end;

    SyncLogFmt('Loaded %d contacts (%d new, %d filtered out) from %s[%s]', [Count, CountNew, CountFiltered, Name, Folder.Name]);
  end;

var I: Integer;
    Folder: MAPIFolder;
begin
  if FFolders.DelimitedText = 'DEFAULT' then begin
    Folder := NmSpace.GetDefaultFolder(olFolderContacts);
    if Assigned(Folder) then
      FFolders.DelimitedText := Folder.EntryID;
  end;

  for I := 0 to FFolders.Count - 1 do begin
    Folder := NmSpace.GetFolderFromID(FFolders[I], '');
    if Assigned(Folder) then
      LoadFolder(Folder);
  end;
end;

function TOutlookContactSource.New: TContact;
begin
  Result := TOutlookContact.Create(Self);
end;

procedure TOutlookContactSource.Read(Contact: TOutlookContact; OutlookContact: ContactItem);
begin
  with OutlookContact do begin
    Contact.Title := Title;
    Contact.Name := FirstName;
    Contact.SurName := LastName;
    Contact.Organization := CompanyName;
    Contact.Email := Email1Address;
    Contact.HomePhone := DeformatPhoneNumber(HomeTelephoneNumber);
    Contact.WorkPhone := DeformatPhoneNumber(BusinessTelephoneNumber);
    Contact.CellPhone := DeformatPhoneNumber(MobileTelephoneNumber);
    Contact.FaxPhone := DeformatPhoneNumber(HomeFaxNumber);
    Contact.OtherPhone := DeformatPhoneNumber(OtherTelephoneNumber);
  end;
end;

procedure TOutlookContactSource.SetCategories(const Value: TStrings);
begin
  FCategories.Assign(Value);
end;

procedure TOutlookContactSource.Update(Contact, Value: TContact);
begin
  with (Contact as TOutlookContact).OutlookContact do begin
    Title := Value.Title;
    FirstName := Value.Name;
    LastName := Value.SurName;
    CompanyName := Value.Organization;
    Email1Address := Value.Email;
    HomeTelephoneNumber := Value.HomePhone;
    BusinessTelephoneNumber := Value.WorkPhone;
    MobileTelephoneNumber := Value.CellPhone;
    HomeFaxNumber := Value.FaxPhone;
    OtherTelephoneNumber := Value.OtherPhone;

    Save;
  end;
end;

procedure TOutlookContactSource.SetFolders(const Value: TStrings);
begin
  FFolders.Assign(Value);
end;

procedure TOutlookContactSource.SetNewContactsFolder(const Value: String);
begin
  if FNewContactsFolder <> Value then begin
    FNewContactsFolder := Value;

    FNewContactsFolderFolder := NmSpace.GetFolderFromID(FNewContactsFolder, '');
  end;
end;

{ TOutlookContact }

function TOutlookContact.Exists: Boolean;
begin
  Result := Assigned(FOutlookContact);
end;

end.